home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / OLE2AUTO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  32.6 KB  |  1,096 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {         OLE2 Automation Controller                    }
  5. {                                                       }
  6. {         Copyright (c) 2001,2002 SGB Software          }
  7. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  8. {                        Igor Pavluk and Serge Korolev  }
  9. {                                                       }
  10. {*******************************************************}
  11.  
  12.  
  13. unit Ole2Auto;
  14.  
  15. interface
  16.  
  17. {$I RX.INC}
  18.  
  19. {$IFDEF WIN32}
  20. uses Windows, SysUtils, {$IFDEF RX_D3} ActiveX, ComObj {$ELSE}
  21.   Ole2, OleAuto, OleCtl {$ENDIF};
  22. {$ELSE}
  23. uses WinTypes, WinProcs, SysUtils, Ole2, Dispatch;
  24. {$ENDIF}
  25.  
  26. const { Maximum number of dispatch arguments }
  27. {$IFDEF RX_D3}
  28.   MaxDispArgs = 64;
  29. {$ELSE}
  30.   MaxDispArgs = 32;
  31. {$ENDIF}
  32.  
  33. {$IFNDEF WIN32}
  34. type
  35.   TDispID = DISPID;
  36.   PDispID = ^TDispID;
  37.   TDispParams = DISPPARAMS;
  38.   TLCID = LCID;
  39.   TExcepInfo = EXCEPINFO;
  40.   PDispIDList = ^TDispIDList;
  41.   TDispIDList = array[0..MaxDispArgs] of TDispID;
  42.   EOleError = class(Exception);
  43. {$ENDIF WIN32}
  44.  
  45. {$IFNDEF RX_D3}
  46. type
  47.   EPropReadOnly = class(EOleError);
  48.   EPropWriteOnly = class(EOleError);
  49. {$ENDIF}
  50.  
  51. {$IFNDEF WIN32}
  52.  
  53. const
  54. { Primary language IDs. }
  55.   LANG_NEUTRAL                     = $00;
  56.  
  57.   LANG_AFRIKAANS                   = $36;
  58.   LANG_ALBANIAN                    = $1C;
  59.   LANG_ARABIC                      = $01;
  60.   LANG_BASQUE                      = $2D;
  61.   LANG_BELARUSIAN                  = $23;
  62.   LANG_BULGARIAN                   = $02;
  63.   LANG_CATALAN                     = $03;
  64.   LANG_CHINESE                     = $04;
  65.   LANG_CROATIAN                    = $1A;
  66.   LANG_CZECH                       = $05;
  67.   LANG_DANISH                      = $06;
  68.   LANG_DUTCH                       = $13;
  69.   LANG_ENGLISH                     = $09;
  70.   LANG_ESTONIAN                    = $25;
  71.   LANG_FAEROESE                    = $38;
  72.   LANG_FARSI                       = $29;
  73.   LANG_FINNISH                     = $0B;
  74.   LANG_FRENCH                      = $0C;
  75.   LANG_GERMAN                      = $07;
  76.   LANG_GREEK                       = $08;
  77.   LANG_HEBREW                      = $0D;
  78.   LANG_HUNGARIAN                   = $0E;
  79.   LANG_ICELANDIC                   = $0F;
  80.   LANG_INDONESIAN                  = $21;
  81.   LANG_ITALIAN                     = $10;
  82.   LANG_JAPANESE                    = $11;
  83.   LANG_KOREAN                      = $12;
  84.   LANG_LATVIAN                     = $26;
  85.   LANG_LITHUANIAN                  = $27;
  86.   LANG_NORWEGIAN                   = $14;
  87.   LANG_POLISH                      = $15;
  88.   LANG_PORTUGUESE                  = $16;
  89.   LANG_ROMANIAN                    = $18;
  90.   LANG_RUSSIAN                     = $19;
  91.   LANG_SERBIAN                     = $1A;
  92.   LANG_SLOVAK                      = $1B;
  93.   LANG_SLOVENIAN                   = $24;
  94.   LANG_SPANISH                     = $0A;
  95.   LANG_SWEDISH                     = $1D;
  96.   LANG_THAI                        = $1E;
  97.   LANG_TURKISH                     = $1F;
  98.   LANG_UKRAINIAN                   = $22;
  99.   LANG_VIETNAMESE                  = $2A;
  100.  
  101. { Sublanguage IDs. }
  102.   SUBLANG_NEUTRAL                  = $00;    { language neutral }
  103.   SUBLANG_DEFAULT                  = $01;    { user default }
  104.   SUBLANG_SYS_DEFAULT              = $02;    { system default }
  105.  
  106.   SUBLANG_CHINESE_TRADITIONAL      = $01;    { Chinese (Taiwan) }
  107.   SUBLANG_CHINESE_SIMPLIFIED       = $02;    { Chinese (PR China) }
  108.   SUBLANG_CHINESE_HONGKONG         = $03;    { Chinese (Hong Kong) }
  109.   SUBLANG_CHINESE_SINGAPORE        = $04;    { Chinese (Singapore) }
  110.   SUBLANG_DUTCH                    = $01;    { Dutch }
  111.   SUBLANG_DUTCH_BELGIAN            = $02;    { Dutch (Belgian) }
  112.   SUBLANG_ENGLISH_US               = $01;    { English (USA) }
  113.   SUBLANG_ENGLISH_UK               = $02;    { English (UK) }
  114.   SUBLANG_ENGLISH_AUS              = $03;    { English (Australian) }
  115.   SUBLANG_ENGLISH_CAN              = $04;    { English (Canadian) }
  116.   SUBLANG_ENGLISH_NZ               = $05;    { English (New Zealand) }
  117.   SUBLANG_ENGLISH_EIRE             = $06;    { English (Irish) }
  118.   SUBLANG_FRENCH                   = $01;    { French }
  119.   SUBLANG_FRENCH_BELGIAN           = $02;    { French (Belgian) }
  120.   SUBLANG_FRENCH_CANADIAN          = $03;    { French (Canadian) }
  121.   SUBLANG_FRENCH_SWISS             = $04;    { French (Swiss) }
  122.   SUBLANG_GERMAN                   = $01;    { German }
  123.   SUBLANG_GERMAN_SWISS             = $02;    { German (Swiss) }
  124.   SUBLANG_GERMAN_AUSTRIAN          = $03;    { German (Austrian) }
  125.   SUBLANG_ITALIAN                  = $01;    { Italian }
  126.   SUBLANG_ITALIAN_SWISS            = $02;    { Italian (Swiss) }
  127.   SUBLANG_NORWEGIAN_BOKMAL         = $01;    { Norwegian (Bokmal) }
  128.   SUBLANG_NORWEGIAN_NYNORSK        = $02;    { Norwegian (Nynorsk) }
  129.   SUBLANG_PORTUGUESE               = $02;    { Portuguese }
  130.   SUBLANG_PORTUGUESE_BRAZILIAN     = $01;    { Portuguese (Brazilian) }
  131.   SUBLANG_SPANISH                  = $01;    { Spanish (Castilian) }
  132.   SUBLANG_SPANISH_MEXICAN          = $02;    { Spanish (Mexican) }
  133.   SUBLANG_SPANISH_MODERN           = $03;    { Spanish (Modern) }
  134.  
  135. { Default System and User IDs for language and locale. }
  136.   LANG_SYSTEM_DEFAULT   = (SUBLANG_SYS_DEFAULT shl 10) or LANG_NEUTRAL;
  137.   LANG_USER_DEFAULT     = (SUBLANG_DEFAULT shl 10) or LANG_NEUTRAL;
  138.   LOCALE_SYSTEM_DEFAULT = (0 shl 16) or LANG_SYSTEM_DEFAULT;
  139.   LOCALE_USER_DEFAULT   = (0 shl 16) or LANG_USER_DEFAULT;
  140.  
  141. { OLE control status codes }
  142.   CTL_E_ILLEGALFUNCTIONCALL       = $800A0000 + 5;
  143.   CTL_E_OVERFLOW                  = $800A0000 + 6;
  144.   CTL_E_OUTOFMEMORY               = $800A0000 + 7;
  145.   CTL_E_DIVISIONBYZERO            = $800A0000 + 11;
  146.   CTL_E_OUTOFSTRINGSPACE          = $800A0000 + 14;
  147.   CTL_E_OUTOFSTACKSPACE           = $800A0000 + 28;
  148.   CTL_E_BADFILENAMEORNUMBER       = $800A0000 + 52;
  149.   CTL_E_FILENOTFOUND              = $800A0000 + 53;
  150.   CTL_E_BADFILEMODE               = $800A0000 + 54;
  151.   CTL_E_FILEALREADYOPEN           = $800A0000 + 55;
  152.   CTL_E_DEVICEIOERROR             = $800A0000 + 57;
  153.   CTL_E_FILEALREADYEXISTS         = $800A0000 + 58;
  154.   CTL_E_BADRECORDLENGTH           = $800A0000 + 59;
  155.   CTL_E_DISKFULL                  = $800A0000 + 61;
  156.   CTL_E_BADRECORDNUMBER           = $800A0000 + 63;
  157.   CTL_E_BADFILENAME               = $800A0000 + 64;
  158.   CTL_E_TOOMANYFILES              = $800A0000 + 67;
  159.   CTL_E_DEVICEUNAVAILABLE         = $800A0000 + 68;
  160.   CTL_E_PERMISSIONDENIED          = $800A0000 + 70;
  161.   CTL_E_DISKNOTREADY              = $800A0000 + 71;
  162.   CTL_E_PATHFILEACCESSERROR       = $800A0000 + 75;
  163.   CTL_E_PATHNOTFOUND              = $800A0000 + 76;
  164.   CTL_E_INVALIDPATTERNSTRING      = $800A0000 + 93;
  165.   CTL_E_INVALIDUSEOFNULL          = $800A0000 + 94;
  166.   CTL_E_INVALIDFILEFORMAT         = $800A0000 + 321;
  167.   CTL_E_INVALIDPROPERTYVALUE      = $800A0000 + 380;
  168.   CTL_E_INVALIDPROPERTYARRAYINDEX = $800A0000 + 381;
  169.   CTL_E_SETNOTSUPPORTEDATRUNTIME  = $800A0000 + 382;
  170.   CTL_E_SETNOTSUPPORTED           = $800A0000 + 383;
  171.   CTL_E_NEEDPROPERTYARRAYINDEX    = $800A0000 + 385;
  172.   CTL_E_SETNOTPERMITTED           = $800A0000 + 387;
  173.   CTL_E_GETNOTSUPPORTEDATRUNTIME  = $800A0000 + 393;
  174.   CTL_E_GETNOTSUPPORTED           = $800A0000 + 394;
  175.   CTL_E_PROPERTYNOTFOUND          = $800A0000 + 422;
  176.   CTL_E_INVALIDCLIPBOARDFORMAT    = $800A0000 + 460;
  177.   CTL_E_INVALIDPICTURE            = $800A0000 + 481;
  178.   CTL_E_PRINTERERROR              = $800A0000 + 482;
  179.   CTL_E_CANTSAVEFILETOTEMP        = $800A0000 + 735;
  180.   CTL_E_SEARCHTEXTNOTFOUND        = $800A0000 + 744;
  181.   CTL_E_REPLACEMENTSTOOLONG       = $800A0000 + 746;
  182.   CTL_E_CUSTOM_FIRST              = $800A0000 + 600;
  183.  
  184. {$ENDIF WIN32}
  185.  
  186. type
  187.  
  188. { OLE2 Automation Controller }
  189.  
  190.   TOleController = class(TObject)
  191.   private
  192.     FLocale: TLCID;
  193.     FObject: Variant;
  194.     FRetValue: Variant;
  195.     function CallMethod(ID: TDispID; const Params: array of const;
  196.       NeedResult: Boolean): PVariant;
  197.     function CallMethodNamedParams(const IDs: TDispIDList;
  198.       const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
  199.     function CallMethodNoParams(ID: TDispID; NeedResult: Boolean): PVariant;
  200.     function Invoke(dispidMember: TDispID; wFlags: Word;
  201.       var pdispparams: TDispParams; Res: PVariant): PVariant;
  202.     function NameToDispID(const AName: string): TDispID;
  203.     function NameToDispIDs(const AName: string;
  204.       const AParams: array of string; Dest: PDispIDList): PDispIDList;
  205.   protected
  206.     procedure ClearObject; virtual;
  207.   public
  208.     constructor Create;
  209.     destructor Destroy; override;
  210.     { create or assign OLE objects }
  211.     procedure CreateObject(const ClassName: string); virtual;
  212.     procedure AssignIDispatch(V: Variant); virtual;
  213.     procedure GetActiveObject(const ClassName: string); virtual;
  214.     { get/set properties of OLE object by ID }
  215.     function GetPropertyByID(ID: TDispID): PVariant;
  216.     procedure SetPropertyByID(ID: TDispID; const Prop: array of const);
  217.     { get/set properties of OLE object }
  218.     function GetProperty(const AName: string): PVariant;
  219.     procedure SetProperty(const AName: string; const Prop: array of const);
  220.     { call OLE functions by IDs }
  221.     function CallFunctionByID(ID: TDispID; const Params: array of const): PVariant;
  222.     function CallFunctionByIDsNamedParams(const IDs: TDispIDList;
  223.       const Params: array of const; Cnt: Byte): PVariant;
  224.     function CallFunctionNoParamsByID(ID: TDispID): PVariant;
  225.     { call OLE procedures by ID }
  226.     procedure CallProcedureByID(ID: TDispID; const Params: array of const);
  227.     procedure CallProcedureByIDsNamedParams(const IDs: TDispIDList;
  228.       const Params: array of const; Cnt: Byte);
  229.     procedure CallProcedureNoParamsByID(ID: TDispID);
  230.     { call OLE functions }
  231.     function CallFunction(const AName: string; const Params: array of const): PVariant;
  232.     function CallFunctionNamedParams(const AName: string; const Params: array of const;
  233.       const ParamNames: array of string): PVariant;
  234.     function CallFunctionNoParams(const AName: string): PVariant;
  235.     { call OLE procedures }
  236.     procedure CallProcedure(const AName: string; const Params: array of const);
  237.     procedure CallProcedureNamedParams(const AName: string; const Params: array of const;
  238.       const ParamNames: array of string);
  239.     procedure CallProcedureNoParams(const AName: string);
  240.     { locale }
  241.     procedure SetLocale(PrimaryLangID, SubLangID: Word);
  242.     property Locale: TLCID read FLocale write FLocale;
  243.     property OleObject: Variant read FObject;
  244.   end;
  245.  
  246. procedure InitOLE;
  247. procedure DoneOLE;
  248. function OleInitialized: Boolean;
  249.  
  250. function MakeLangID(PrimaryLangID, SubLangID: Word): Word;
  251. function MakeLCID(LangID: Word): TLCID;
  252. function CreateLCID(PrimaryLangID, SubLangID: Word): TLCID;
  253. function ExtractLangID(LCID: TLCID): Word;
  254. function ExtractSubLangID(LCID: TLCID): Word;
  255.  
  256. {$IFNDEF WIN32}
  257.  
  258. procedure OleCheck(OleResult: HResult);
  259.  
  260. { OLE string support }
  261. function OleStrToString(Source: BSTR): string;
  262. function StringToOleStr(const Source: string): BSTR;
  263. function StringToClassID(const S: string): CLSID;
  264. function ClassIDToString(const CLSID: CLSID): string;
  265.  
  266. { Create or get active OLE object for a given a class name }
  267. function CreateOleObject(const ClassName: string): Variant;
  268. function GetActiveOleObject(const ClassName: string): Variant;
  269.  
  270. {$ENDIF WIN32}
  271.  
  272. implementation
  273.  
  274. uses Forms;
  275.  
  276. {$IFDEF RX_D3}
  277. resourcestring
  278. {$ELSE}
  279. const
  280. {$ENDIF}
  281.   SOleInvalidVer   = 'Invalid OLE library version';
  282.   SOleInitFailed   = 'OLE Library initialization failed. Error code: %.8xH';
  283.   SOleNotInit      = 'OLE2 Library not initialized';
  284.   SOleInvalidParam = 'Invalid parameter value';
  285.   SOleNotSupport   = 'Method or property %s not supported by OLE object';
  286.   SOleNotReference = 'Variant does not reference an OLE automation object';
  287. {$IFNDEF RX_D3}
  288.   SOleError        = 'OLE2 error occured. Error code: %.8xH';
  289. {$ENDIF}
  290.  
  291. const
  292.   FOleInitialized: Boolean = False;
  293.  
  294. const
  295. { OLE2 Version }
  296.   RMJ =   0;
  297.   RMM =  23;
  298.   RUP = 639;
  299.  
  300. const
  301.   DISPATCH_METHODNOPARAM = DISPATCH_METHOD or DISPATCH_PROPERTYGET;
  302.   DISPATCH_METHODPARAMS = DISPATCH_METHOD
  303.     {$IFDEF WIN32} or DISPATCH_PROPERTYGET {$ENDIF};
  304.  
  305. {$IFDEF WIN32}
  306.  
  307. function FailedHR(hr: HResult): Boolean;
  308. begin
  309.   Result := Failed(hr);
  310. end;
  311.  
  312. {$ELSE WIN32}
  313.  
  314. { Standard OLE class pathes }
  315.  
  316. type
  317.   IDispatch = class(IUnknown)
  318.     function GetTypeInfoCount(var pctinfo: Integer): HResult; virtual; cdecl; export; abstract;
  319.     function GetTypeInfo(itinfo: Integer; TLCID: TLCID; var pptinfo: ITypeInfo): HResult; virtual; cdecl; export; abstract;
  320.     function GetIDsOfNames(const riid: IID; var rgszNames: PChar;
  321.       cNames: Integer; TLCID: TLCID; rgdispid: PDispID): HResult; virtual; cdecl; export; abstract;
  322.     function Invoke(dispidMember: TDispID; const riid: IID; TLCID: TLCID;
  323.       wFlags: Word; var pdispparams: TDispParams; pvarResult: PVARIANT;
  324.       var pexcepinfo: TExcepInfo; var puArgErr: Integer): HResult; virtual; cdecl; export; abstract;
  325.   end;
  326.  
  327. function DispInvoke(_this: Pointer; ptinfo: ITypeInfo; dispidMember: TDispID;
  328.   wFlags: Word; var pparams: TDispParams; pvarResult: PVARIANT;
  329.   var pexcepinfo: TExcepInfo; var puArgErr: Integer): HResult; far; external 'ole2disp';
  330. function DispGetIDsOfNames(ptinfo: ITypeInfo; var rgszNames: PChar;
  331.   cNames: Integer; rgdispid: PDispID): HResult; far; external 'ole2disp';
  332.  
  333. function GUID_NULL: GUID;
  334. begin
  335.   Result := IID_NULL;
  336. end;
  337.  
  338. {$ENDIF WIN32}
  339.  
  340. { Standard OLE Library initialization code }
  341.  
  342. procedure InitOLE;
  343. var
  344.   dwVer: Longint;
  345.   HRes: HResult;
  346. begin
  347.   if FOleInitialized then Exit;
  348.   dwVer := Longint(CoBuildVersion);
  349.   if (RMM <> HiWord(dwVer)) or (RUP > LoWord(dwVer)) then
  350.     raise EOleError.Create(SOleInvalidVer)
  351.   else begin
  352.     HRes := OleInitialize(nil);
  353.     if FailedHR(HRes) then
  354.       raise EOleError.CreateFmt(SOleInitFailed, [Longint(HRes)])
  355.     else FOleInitialized := True;
  356.   end;
  357. end;
  358.  
  359. { Standard OLE Library exit code }
  360.  
  361. procedure DoneOLE;
  362. begin
  363.   if FOleInitialized then OleUninitialize;
  364.   FOleInitialized := False;
  365. end;
  366.  
  367. function OleInitialized: Boolean;
  368. begin
  369.   Result := FOleInitialized;
  370. end;
  371.  
  372. procedure CheckOleInitialized;
  373. begin
  374.   if not FOleInitialized then raise EOleError.Create(SOleNotInit);
  375. end;
  376.  
  377. {$IFNDEF RX_D3}
  378. function OleErrorMsg(ErrorCode: HResult): string;
  379. begin
  380.   FmtStr(Result, SOleError, [Longint(ErrorCode)]);
  381. end;
  382. {$ENDIF}
  383.  
  384. {$IFNDEF WIN32}
  385.  
  386. procedure OleError(ErrorCode: HResult);
  387. begin
  388.   raise EOleError.Create(OleErrorMsg(ErrorCode));
  389. end;
  390.  
  391. { Raise EOleError exception if result code indicates an error }
  392.  
  393. procedure OleCheck(OleResult: HResult);
  394. begin
  395.   if FailedHR(OleResult) then OleError(OleResult);
  396. end;
  397.  
  398. {$ENDIF WIN32}
  399.  
  400. { Raise exception given an OLE return code and TExcepInfo structure }
  401.  
  402. procedure DispInvokeError(Status: HResult; const ExcepInfo: TExcepInfo);
  403. {$IFDEF RX_D3}
  404. begin
  405.   DispatchInvokeError(Status, ExcepInfo);
  406. {$ELSE}
  407. var
  408.   EClass: ExceptClass;
  409.   Message: string;
  410. begin
  411.   EClass := EOleError;
  412.   if Longint(Status) <> DISP_E_EXCEPTION then
  413.     Message := OleErrorMsg(Status)
  414.   else
  415.     with ExcepInfo do
  416.     begin
  417.       try
  418.         if (scode = CTL_E_SETNOTSUPPORTED) or
  419.           (scode = CTL_E_SETNOTSUPPORTEDATRUNTIME) then
  420.             EClass := EPropReadOnly
  421.         else if (scode = CTL_E_GETNOTSUPPORTED) or
  422.           (scode = CTL_E_GETNOTSUPPORTEDATRUNTIME) then
  423.             EClass := EPropWriteOnly;
  424.         if bstrDescription <> nil then begin
  425.           Message := OleStrToString(bstrDescription);
  426.           while (Length(Message) > 0) and
  427.             (Message[Length(Message)] in [#0..#32, '.']) do
  428.             Delete(Message, Length(Message), 1);
  429.         end;
  430.       finally
  431.         if bstrSource <> nil then SysFreeString(bstrSource);
  432.         if bstrDescription <> nil then SysFreeString(bstrDescription);
  433.         if bstrHelpFile <> nil then SysFreeString(bstrHelpFile);
  434.       end;
  435.     end;
  436.   if Message = '' then Message := OleErrorMsg(Status);
  437.   raise EClass.Create(Message);
  438. {$ENDIF RX_D3}
  439. end;
  440.  
  441. {$IFNDEF WIN32}
  442.  
  443. { Convert a string to a class ID }
  444.  
  445. function StringToClassID(const S: string): CLSID;
  446. var
  447.   CharBuf: array[0..64] of Char;
  448. begin
  449.   OleCheck(CLSIDFromString(StrPLCopy(CharBuf, S, SizeOf(CharBuf) - 1),
  450.     Result));
  451. end;
  452.  
  453. { Convert a class ID to a string }
  454.  
  455. function ClassIDToString(const CLSID: CLSID): string;
  456. var
  457.   P: PChar;
  458.   Malloc: IMalloc;
  459. begin
  460.   OleCheck(CoGetMalloc(MEMCTX_TASK, Malloc));
  461.   OleCheck(StringFromCLSID(CLSID, P));
  462.   Result := StrPas(P);
  463.   Malloc.Free(P);
  464. end;
  465.  
  466. { Create an OLE object variant given an IDispatch }
  467.  
  468. function VarFromInterface(Unknown: IUnknown): Variant;
  469. var
  470.   Disp: IDispatch;
  471. begin
  472.   VariantClear(VARIANTARG(Result));
  473.   VariantInit(VARIANTARG(Result));
  474.   try
  475.     if Unknown <> nil then begin
  476.       OleCheck(Unknown.QueryInterface(IID_IDispatch, Disp));
  477.       Result.VT := VT_DISPATCH;
  478.       Result.pdispVal := Dispatch.IDispatch(Disp);
  479.     end;
  480.   except
  481.     VariantClear(VARIANTARG(Result));
  482.     raise;
  483.   end;
  484. end;
  485.  
  486. { Return OLE object stored in a variant }
  487.  
  488. function VarToInterface(const V: Variant): IDispatch;
  489. begin
  490.   Result := nil;
  491.   if V.VT = VT_DISPATCH then
  492.     Result := IDispatch(V.pdispVal)
  493.   else if V.VT = (VT_DISPATCH or VT_BYREF) then
  494.     Result := IDispatch(V.ppdispVal^);
  495.   if Result = nil then raise EOleError.Create(SOleNotReference);
  496. end;
  497.  
  498. { Create an OLE object variant given a class name }
  499.  
  500. function CreateOleObject(const ClassName: string): Variant;
  501. var
  502.   Unknown: IUnknown;
  503.   ClassID: CLSID;
  504.   CharBuf: array[0..127] of Char;
  505. begin
  506.   StrPLCopy(CharBuf, ClassName, SizeOf(CharBuf) - 1);
  507.   OleCheck(CLSIDFromProgID(@CharBuf, ClassID));
  508.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  509.     CLSCTX_LOCAL_SERVER, IID_IUnknown, Unknown));
  510.   try
  511.     Result := VarFromInterface(Unknown);
  512.   finally
  513.     Unknown.Release;
  514.   end;
  515. end;
  516.  
  517. { Get active OLE object for a given class name }
  518.  
  519. function GetActiveOleObject(const ClassName: string): Variant;
  520. var
  521.   Unknown: IUnknown;
  522.   ClassID: CLSID;
  523.   CharBuf: array[0..127] of Char;
  524. begin
  525.   StrPLCopy(CharBuf, ClassName, SizeOf(CharBuf) - 1);
  526.   OleCheck(CLSIDFromProgID(@CharBuf, ClassID));
  527.   OleCheck(GetActiveObject(ClassID, nil, Unknown));
  528.   try
  529.     Result := VarFromInterface(Unknown);
  530.   finally
  531.     Unknown.Release;
  532.   end;
  533. end;
  534.  
  535. { OLE string support }
  536.  
  537. function OleStrToString(Source: BSTR): string;
  538. begin
  539.   Result := StrPas(Source);
  540. end;
  541.  
  542. function StringToOleStr(const Source: string): BSTR;
  543. var
  544.   SourceLen: Integer;
  545.   CharBuf: array[0..255] of Char;
  546. begin
  547.   SourceLen := Length(Source);
  548.   if SourceLen > 0 then begin
  549.     StrPLCopy(CharBuf, Source, SizeOf(CharBuf) - 1);
  550.     Result := SysAllocStringLen(CharBuf, SourceLen);
  551.   end
  552.   else Result := nil;
  553. end;
  554.  
  555. {$ELSE}
  556.  {$IFDEF RX_D3}
  557.  
  558. { Return OLE object stored in a variant }
  559.  
  560. function VarToInterface(const V: Variant): IDispatch;
  561. begin
  562.   Result := nil;
  563.   if TVarData(V).VType = varDispatch then
  564.     Result := IDispatch(TVarData(V).VDispatch)
  565.   else if TVarData(V).VType = (varDispatch or varByRef) then
  566.     Result := IDispatch(Pointer(TVarData(V).VPointer^));
  567.   if Result = nil then raise EOleError.Create(SOleNotReference);
  568. end;
  569.  
  570.  {$ENDIF}
  571. {$ENDIF}
  572.  
  573. { Assign Variant }
  574.  
  575. procedure AssignVariant(
  576.   var Dest: {$IFDEF WIN32} TVariantArg; {$ELSE} Variant; {$ENDIF}
  577.   const Value: TVarRec);
  578. begin
  579. {$IFNDEF WIN32}
  580.   VariantInit(VARIANTARG(Dest));
  581.   try
  582. {$ENDIF}
  583.     with Value do
  584.       case VType of
  585.         vtInteger:
  586.           begin
  587.             Dest.vt := VT_I4;
  588.             Dest.lVal := VInteger;
  589.           end;
  590.         vtBoolean:
  591.           begin
  592.             Dest.vt := VT_BOOL;
  593.             Dest.vbool := VBoolean;
  594.           end;
  595.         vtChar:
  596.           begin
  597.             Dest.vt := VT_BSTR;
  598.             Dest.bstrVal := StringToOleStr(VChar);
  599.           end;
  600.         vtExtended:
  601.           begin
  602.             Dest.vt := VT_R8;
  603.             Dest.dblVal := VExtended^;
  604.           end;
  605.         vtString:
  606.           begin
  607.             Dest.vt := VT_BSTR;
  608.             Dest.bstrVal := StringToOleStr(VString^);
  609.           end;
  610.         vtPointer:
  611.           if VPointer = nil then begin
  612.             Dest.vt := VT_NULL;
  613.             Dest.byRef := nil;
  614.           end
  615.           else begin
  616.             Dest.vt := VT_BYREF;
  617.             Dest.byRef := VPointer;
  618.           end;
  619.         vtPChar:
  620.           begin
  621.             Dest.vt := VT_BSTR;
  622.             Dest.bstrVal := StringToOleStr(StrPas(VPChar));
  623.           end;
  624.         vtObject:
  625.           begin
  626.             Dest.vt := VT_BYREF;
  627.             Dest.byRef := VObject;
  628.           end;
  629. {$IFDEF WIN32}
  630.         vtClass:
  631.           begin
  632.             Dest.vt := VT_BYREF;
  633.             Dest.byRef := VClass;
  634.           end;
  635.         vtWideChar:
  636.           begin
  637.             Dest.vt := VT_BSTR;
  638.             Dest.bstrVal := @VWideChar;
  639.           end;
  640.         vtPWideChar:
  641.           begin
  642.             Dest.vt := VT_BSTR;
  643.             Dest.bstrVal := VPWideChar;
  644.           end;
  645.         vtAnsiString:
  646.           begin
  647.             Dest.vt := VT_BSTR;
  648.             Dest.bstrVal := StringToOleStr(string(VAnsiString));
  649.           end;
  650.         vtCurrency:
  651.           begin
  652.             Dest.vt := VT_CY;
  653.             Dest.cyVal := VCurrency^;
  654.           end;
  655.         vtVariant:
  656.           begin
  657.             Dest.vt := VT_BYREF or VT_VARIANT;
  658.             Dest.pvarVal := VVariant;
  659.           end;
  660. {$ENDIF WIN32}
  661. {$IFDEF RX_D4}
  662.         vtInterface:
  663.           begin
  664.             Dest.vt := VT_UNKNOWN or VT_BYREF;
  665.             Dest.byRef := VInterface;
  666.           end;
  667.         vtInt64:
  668.           begin
  669.             Dest.vt := VT_I8 or VT_BYREF;
  670.             Dest.byRef := VInt64;
  671.           end;
  672. {$ENDIF RX_D4}
  673.         else raise EOleError.Create(SOleInvalidParam);
  674.       end;
  675. {$IFNDEF WIN32}
  676.   except
  677.     VariantClear(VARIANTARG(Dest));
  678.     raise;
  679.   end;
  680. {$ENDIF}
  681. end;
  682.  
  683. { TOleController }
  684.  
  685. constructor TOleController.Create;
  686. begin
  687.   inherited Create;
  688. {$IFDEF WIN32}
  689.   FLocale := GetThreadLocale;
  690. {$ELSE}
  691.   FLocale := LOCALE_SYSTEM_DEFAULT;
  692. {$ENDIF}
  693.   try
  694.     InitOLE;
  695.   except
  696.     Application.HandleException(Self);
  697.   end;
  698. end;
  699.  
  700. destructor TOleController.Destroy;
  701. begin
  702.   if FOleInitialized then ClearObject;
  703.   inherited Destroy;
  704. end;
  705.  
  706. procedure TOleController.CreateObject(const ClassName: string);
  707. begin
  708.   CheckOleInitialized;
  709.   ClearObject;
  710.   FObject := CreateOleObject(ClassName);
  711. end;
  712.  
  713. procedure TOleController.GetActiveObject(const ClassName: string);
  714. begin
  715.   CheckOleInitialized;
  716.   ClearObject;
  717.   FObject := GetActiveOleObject(ClassName);
  718. end;
  719.  
  720. procedure TOleController.AssignIDispatch(V: Variant);
  721. begin
  722.   CheckOleInitialized;
  723.   ClearObject;
  724.   VarToInterface(V);
  725. {$IFDEF WIN32}
  726.   VarCopy(FObject, V);
  727. {$ELSE}
  728.   VariantCopy(VARIANTARG(FObject), V);
  729. {$ENDIF}
  730. end;
  731.  
  732. procedure TOleController.ClearObject;
  733. begin
  734. {$IFDEF WIN32}
  735.   VarClear(FRetValue);
  736.   VarClear(FObject);
  737. {$ELSE}
  738.   VariantClear(VARIANTARG(FRetValue));
  739.   VariantClear(VARIANTARG(FObject));
  740. {$ENDIF}
  741. end;
  742.  
  743. function TOleController.NameToDispID(const AName: string): TDispID;
  744. var
  745. {$IFDEF WIN32}
  746.   CharBuf: array[0..255] of WideChar;
  747.   P: array[0..0] of PWideChar;
  748. {$ELSE}
  749.   CharBuf: array[0..255] of Char;
  750.   P: PChar;
  751. {$ENDIF}
  752. begin
  753.   CheckOleInitialized;
  754. {$IFDEF WIN32}
  755.   StringToWideChar(AName, @CharBuf, 256);
  756.   P[0] := @CharBuf[0];
  757. {$ELSE}
  758.   StrPLCopy(CharBuf, AName, SizeOf(CharBuf) - 1);
  759.   P := @CharBuf;
  760. {$ENDIF}
  761.   if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
  762.     {$IFDEF WIN32} @P, {$ELSE} P, {$ENDIF} 1, FLocale, @Result)) then
  763.     raise EOleError.CreateFmt(SOleNotSupport, [AName]);
  764. end;
  765.  
  766. function TOleController.NameToDispIDs(const AName: string;
  767.   const AParams: array of string; Dest: PDispIDList): PDispIDList;
  768. var
  769. {$IFDEF WIN32}
  770.   CharBuf: array[0..MaxDispArgs] of PWideChar;
  771.   Size: Integer;
  772. {$ELSE}
  773.   CharBuf: array[0..MaxDispArgs] of PChar;
  774. {$ENDIF}
  775.   I: Byte;
  776. begin
  777.   Result := Dest;
  778.   CheckOleInitialized;
  779. {$IFDEF WIN32}
  780.   Size := Length(AName) + 1;
  781.   GetMem(CharBuf[0], Size * SizeOf(WideChar));
  782.   StringToWideChar(AName, CharBuf[0], Size);
  783.   for I := 0 to High(AParams) do begin
  784.     Size := Length(AParams[I]) + 1;
  785.     GetMem(CharBuf[I + 1], Size * SizeOf(WideChar));
  786.     StringToWideChar(AParams[I], CharBuf[I + 1], Size);
  787.   end;
  788. {$ELSE}
  789.   CharBuf[0] := StrPCopy(StrAlloc(Length(AName) + 1), AName);
  790.   for I := 0 to High(AParams) do
  791.     CharBuf[I + 1] := StrPCopy(StrAlloc(Length(AParams[I]) + 1), AParams[I]);
  792. {$ENDIF}
  793.   try
  794.     if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
  795.       {$IFDEF WIN32} @CharBuf, {$ELSE} CharBuf[0], {$ENDIF}
  796.       High(AParams) + 2, FLocale, @Result^[0]))
  797.     then
  798.       raise EOleError.CreateFmt(SOleNotSupport, [AName]);
  799.   finally
  800. {$IFDEF WIN32}
  801.     for I := 0 to High(AParams) + 1 do FreeMem(CharBuf[I]);
  802. {$ELSE}
  803.     for I := 0 to High(AParams) + 1 do StrDispose(CharBuf[I]);
  804. {$ENDIF}
  805.   end;
  806. end;
  807.  
  808. function TOleController.Invoke(dispidMember: TDispID; wFlags: Word;
  809.   var pdispparams: TDispParams; Res: PVariant): PVariant;
  810. var
  811.   pexcepinfo: TExcepInfo;
  812.   puArgErr: Integer;
  813.   HRes: HResult;
  814. begin
  815. {$IFDEF WIN32}
  816.   if Res <> nil then VarClear(Res^);
  817.   try
  818.     HRes := VarToInterface(FObject).Invoke(dispidMember, GUID_NULL,
  819.       FLocale, wFlags, pdispparams, Res, @pexcepinfo, @puArgErr);
  820.   except
  821.     if Res <> nil then VarClear(Res^);
  822.     raise;
  823.   end;
  824. {$ELSE}
  825.   if Res <> nil then begin
  826.     VariantClear(VARIANTARG(Res^));
  827.     VariantInit(VARIANTARG(Res^));
  828.   end;
  829.   try
  830.     HRes := VarToInterface(FObject).Invoke(dispidMember, GUID_NULL,
  831.       FLocale, wFlags, pdispparams, Res, pexcepinfo, puArgErr);
  832.   except
  833.     if Res <> nil then VariantClear(VARIANTARG(Res^));
  834.     raise;
  835.   end;
  836. {$ENDIF}
  837.   if FailedHR(HRes) then DispInvokeError(HRes, pexcepinfo);
  838.   Result := Res;
  839. end;
  840.  
  841. function TOleController.CallMethodNoParams(ID: TDispID;
  842.   NeedResult: Boolean): PVariant;
  843. const
  844.   Disp: TDispParams = (rgvarg: nil; rgdispidNamedArgs: nil; cArgs: 0;
  845.     cNamedArgs: 0);
  846. begin
  847.   CheckOleInitialized;
  848.   if NeedResult then
  849.     Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, @FRetValue)
  850.   else
  851.     Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, nil);
  852. end;
  853.  
  854. function TOleController.CallMethod(ID: TDispID; const Params: array of const;
  855.   NeedResult: Boolean): PVariant;
  856. var
  857.   Disp: TDispParams;
  858.   ArgCnt, I: Integer;
  859. {$IFDEF WIN32}
  860.   Args: array[0..MaxDispArgs - 1] of TVariantArg;
  861. {$ELSE}
  862.   Args: array[0..MaxDispArgs - 1] of Variant;
  863. {$ENDIF}
  864. begin
  865.   CheckOleInitialized;
  866.   ArgCnt := 0;
  867.   try
  868.     for I := 0 to High(Params) do begin
  869.       AssignVariant(Args[I], Params[I]);
  870.       Inc(ArgCnt);
  871.       if ArgCnt >= MaxDispArgs then Break;
  872.     end;
  873.     with Disp do begin
  874.       if ArgCnt = 0 then rgvarg := nil
  875.       else rgvarg := @Args;
  876.       rgdispidNamedArgs := nil;
  877.       cArgs := ArgCnt;
  878.       cNamedArgs := 0;
  879.     end;
  880.     if NeedResult then
  881.       Result := Invoke(ID, DISPATCH_METHODPARAMS, Disp, @FRetValue)
  882.     else
  883.       Result := Invoke(ID, DISPATCH_METHODPARAMS, Disp, nil);
  884.   finally
  885. {$IFNDEF WIN32}
  886.     for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
  887. {$ENDIF}
  888.   end;
  889. end;
  890.  
  891. function TOleController.CallMethodNamedParams(const IDs: TDispIDList;
  892.   const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
  893. var
  894.   Disp: TDispParams;
  895.   ArgCnt, I: Integer;
  896. {$IFDEF WIN32}
  897.   Args: array[0..MaxDispArgs - 1] of TVariantArg;
  898. {$ELSE}
  899.   Args: array[0..MaxDispArgs - 1] of Variant;
  900. {$ENDIF}
  901. begin
  902.   CheckOleInitialized;
  903.   ArgCnt := 0;
  904.   try
  905.     for I := 0 to High(Params) do begin
  906.       AssignVariant(Args[I], Params[I]);
  907.       Inc(ArgCnt);
  908.       if ArgCnt >= MaxDispArgs then Break;
  909.     end;
  910.     with Disp do begin
  911.       if ArgCnt = 0 then rgvarg := nil
  912.       else rgvarg := @Args;
  913.       if Cnt = 0 then rgdispidNamedArgs := nil
  914.       else rgdispidNamedArgs := @IDs[1];
  915.       cArgs := ArgCnt;
  916.       cNamedArgs := Cnt;
  917.     end;
  918.     if NeedResult then
  919.       Result := Invoke(IDs[0], DISPATCH_METHODPARAMS, Disp, @FRetValue)
  920.     else
  921.       Result := Invoke(IDs[0], DISPATCH_METHODPARAMS, Disp, nil);
  922.   finally
  923. {$IFNDEF WIN32}
  924.     for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
  925. {$ENDIF}
  926.   end;
  927. end;
  928.  
  929. procedure TOleController.SetPropertyByID(ID: TDispID; const Prop: array of const);
  930. const
  931.   NameArg: TDispID = DISPID_PROPERTYPUT;
  932. var
  933.   Disp: TDispParams;
  934.   ArgCnt, I: Integer;
  935. {$IFDEF WIN32}
  936.   Args: array[0..MaxDispArgs - 1] of TVariantArg;
  937. {$ELSE}
  938.   Args: array[0..MaxDispArgs - 1] of Variant;
  939. {$ENDIF}
  940. begin
  941.   CheckOleInitialized;
  942.   ArgCnt := 0;
  943.   try
  944.     for I := 0 to High(Prop) do begin
  945.       AssignVariant(Args[I], Prop[I]);
  946.       Inc(ArgCnt);
  947.       if ArgCnt >= MaxDispArgs then Break;
  948.     end;
  949.     with Disp do begin
  950.       rgvarg := @Args;
  951.       rgdispidNamedArgs := @NameArg;
  952.       cArgs := ArgCnt;
  953.       cNamedArgs := 1;
  954.     end;
  955.     Invoke(ID, DISPATCH_PROPERTYPUT, Disp, nil);
  956.   finally
  957. {$IFNDEF WIN32}
  958.     for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
  959. {$ENDIF}
  960.   end;
  961. end;
  962.  
  963. function TOleController.GetPropertyByID(ID: TDispID): PVariant;
  964. const
  965.   Disp: TDispParams = (rgvarg: nil; rgdispidNamedArgs: nil;
  966.     cArgs: 0; cNamedArgs: 0);
  967. begin
  968.   CheckOleInitialized;
  969.   Result := Invoke(ID, DISPATCH_PROPERTYGET, Disp, @FRetValue);
  970. end;
  971.  
  972. procedure TOleController.CallProcedureByID(ID: TDispID; const Params: array of const);
  973. begin
  974.   CallMethod(ID, Params, False);
  975. end;
  976.  
  977. function TOleController.CallFunctionByID(ID: TDispID;
  978.   const Params: array of const): PVariant;
  979. begin
  980.   Result := CallMethod(ID, Params, True);
  981. end;
  982.  
  983. procedure TOleController.CallProcedureByIDsNamedParams(const IDs: TDispIDList;
  984.   const Params: array of const; Cnt: Byte);
  985. begin
  986.   CallMethodNamedParams(IDs, Params, Cnt, False);
  987. end;
  988.  
  989. function TOleController.CallFunctionByIDsNamedParams(const IDs: TDispIDList;
  990.   const Params: array of const; Cnt: Byte): PVariant;
  991. begin
  992.   Result := CallMethodNamedParams(IDs, Params, Cnt, True);
  993. end;
  994.  
  995. procedure TOleController.CallProcedureNoParamsByID(ID: TDispID);
  996. begin
  997.   CallMethodNoParams(ID, False);
  998. end;
  999.  
  1000. function TOleController.CallFunctionNoParamsByID(ID: TDispID): PVariant;
  1001. begin
  1002.   Result := CallMethodNoParams(ID, True);
  1003. end;
  1004.  
  1005. procedure TOleController.SetProperty(const AName: string;
  1006.   const Prop: array of const);
  1007. begin
  1008.   SetPropertyByID(NameToDispID(AName), Prop);
  1009. end;
  1010.  
  1011. function TOleController.GetProperty(const AName: string): PVariant;
  1012. begin
  1013.   Result := GetPropertyByID(NameToDispID(AName));
  1014. end;
  1015.  
  1016. procedure TOleController.CallProcedure(const AName: string;
  1017.   const Params: array of const);
  1018. begin
  1019.   CallProcedureByID(NameToDispID(AName), Params);
  1020. end;
  1021.  
  1022. function TOleController.CallFunction(const AName: string;
  1023.   const Params: array of const): PVariant;
  1024. begin
  1025.   Result := CallFunctionByID(NameToDispID(AName), Params);
  1026. end;
  1027.  
  1028. procedure TOleController.CallProcedureNamedParams(const AName: string;
  1029.   const Params: array of const; const ParamNames: array of string);
  1030. var
  1031.   DispIDs: array[0..MaxDispArgs] of TDispID;
  1032. begin
  1033.   CallProcedureByIDsNamedParams(NameToDispIDs(AName, ParamNames, @DispIDs)^,
  1034.     Params, High(ParamNames) + 1);
  1035. end;
  1036.  
  1037. function TOleController.CallFunctionNamedParams(const AName: string;
  1038.   const Params: array of const; const ParamNames: array of string): PVariant;
  1039. var
  1040.   DispIDs: array[0..MaxDispArgs] of TDispID;
  1041. begin
  1042.   Result := CallFunctionByIDsNamedParams(NameToDispIDs(AName, ParamNames,
  1043.     @DispIDs)^, Params, High(ParamNames) + 1);
  1044. end;
  1045.  
  1046. procedure TOleController.CallProcedureNoParams(const AName: string);
  1047. begin
  1048.   CallProcedureNoParamsByID(NameToDispID(AName));
  1049. end;
  1050.  
  1051. function TOleController.CallFunctionNoParams(const AName: string): PVariant;
  1052. begin
  1053.   Result := CallFunctionNoParamsByID(NameToDispID(AName));
  1054. end;
  1055.  
  1056. procedure TOleController.SetLocale(PrimaryLangID, SubLangID: Word);
  1057. begin
  1058.   FLocale := CreateLCID(PrimaryLangID, SubLangID);
  1059. end;
  1060.  
  1061. { Utility routines }
  1062.  
  1063. function MakeLangID(PrimaryLangID, SubLangID: Word): Word;
  1064. begin
  1065.   Result := (SubLangID shl 10) or PrimaryLangID;
  1066. end;
  1067.  
  1068. function MakeLCID(LangID: Word): TLCID;
  1069. begin
  1070.   Result := TLCID(LangID or (Longint(0) shl 16));
  1071. end;
  1072.  
  1073. function CreateLCID(PrimaryLangID, SubLangID: Word): TLCID;
  1074. begin
  1075.   Result := MakeLCID(MakeLangID(PrimaryLangID, SubLangID));
  1076. end;
  1077.  
  1078. function ExtractLangID(LCID: TLCID): Word;
  1079. begin
  1080.   Result := LCID and $FF;
  1081. end;
  1082.  
  1083. function ExtractSubLangID(LCID: TLCID): Word;
  1084. begin
  1085.   Result := LCID and ($FF shl 10) shr 10;
  1086. end;
  1087.  
  1088. {$IFDEF WIN32}
  1089. initialization
  1090. finalization
  1091.   DoneOLE;
  1092. {$ELSE}
  1093. initialization
  1094.   AddExitProc(DoneOLE);
  1095. {$ENDIF}
  1096. end.